home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Aminet 1 (Walnut Creek)
/
Aminet - June 1993 [Walnut Creek].iso
/
aminet
/
util
/
gnu
/
gnu_smalltalk1_2.lha
/
browse.el
< prev
next >
Wrap
Lisp/Scheme
|
1992-02-18
|
10KB
|
347 lines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright (C) 1988, 1989, 1990 Free Software Foundation, Inc.
;;; Written by Steve Byrne.
;;;
;;; This file is part of GNU Smalltalk.
;;;
;;; GNU Smalltalk is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by the Free
;;; Software Foundation; either version 1, or (at your option) any later
;;; version.
;;;
;;; GNU Smalltalk is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;;; for more details.
;;;
;;; You should have received a copy of the GNU General Public License along
;;; with GNU Smalltalk; see the file COPYING. If not, write to the Free
;;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide 'browse)
(defvar smalltalk-indicator "=>"
"Used to mark the selected class or method when browsing")
(defvar smalltalk-br-mode-map nil "Local keymap for smalltalk-br-mode buffers.")
(if smalltalk-br-mode-map
nil
(setq smalltalk-br-mode-map (make-keymap))
(suppress-keymap smalltalk-br-mode-map)
(define-key smalltalk-br-mode-map " " 'smalltalk-br-browse-def))
;; Smalltalk-Br mode is suitable only for specially formatted data.
(put 'smalltalk-br-mode 'mode-class 'special)
(defun smalltalk-br-mode (func vec)
"Mode for browsing Smalltalk \"collections\"
\\{smalltalk-br-mode-map}"
(interactive)
(kill-all-local-variables)
(setq major-mode 'smalltalk-br-mode)
(setq mode-name "ST Browse")
(setq indent-tabs-mode nil)
(make-local-variable 'smalltalk-br-func)
(setq smalltalk-br-func func)
(make-local-variable 'smalltalk-br-vector)
(setq smalltalk-br-vector vec)
;; (setq mode-line-buffer-identification '("Smalltalk-Br: %17b"))
(setq buffer-read-only t)
(use-local-map smalltalk-br-mode-map)
(run-hooks 'smalltalk-br-mode-hook))
(defun smalltalk-hier-br-mode (vec)
"Mode for browsing Smalltalk hierarchy
\\{smalltalk-br-mode-map}"
(interactive)
(let (map)
(kill-all-local-variables)
(setq major-mode 'smalltalk-br-mode
mode-name "Hier Browse"
buffer-read-only t
truncate-lines t
indent-tabs-mode nil
)
(make-local-variable 'smalltalk-br-func)
(setq smalltalk-br-func 'smalltalk-br-selected)
(make-local-variable 'smalltalk-br-vector)
(make-local-variable 'smalltalk-prev-indicator)
(setq smalltalk-br-vector vec)
(setq map (copy-keymap smalltalk-br-mode-map))
;; old def'n
;(define-key map " " 'smalltalk-arrow-br-browse-def)
(define-key map " " 'smalltalk-browse-all-methods)
(define-key map "d" 'smalltalk-browse-direct-methods)
(define-key map "i" 'smalltalk-browse-indirect-methods)
(define-key map "c" 'smalltalk-browse-class-methods)
(use-local-map map)
(delete-other-windows)
(run-hooks 'smalltalk-br-mode-hook)
)
)
(defun smalltalk-method-br-mode (vec)
"Mode for browsing Smalltalk hierarchy
\\{smalltalk-br-mode-map}"
(interactive)
(let (map)
(kill-all-local-variables)
(setq major-mode 'smalltalk-br-mode
mode-name "Method Browse"
buffer-read-only t
truncate-lines t
)
(make-local-variable 'smalltalk-br-func)
(setq smalltalk-br-func 'test-func)
(make-local-variable 'smalltalk-br-vector)
(setq smalltalk-br-vector vec)
(make-local-variable 'smalltalk-prev-indicator)
(setq smalltalk-prev-indicator nil) ;in case we reused this buffer
(setq map (copy-keymap smalltalk-br-mode-map))
(define-key map " " 'smalltalk-arrow-br-browse-def)
(use-local-map map)
(run-hooks 'smalltalk-br-mode-hook)
)
)
(defun smalltalk-browse (name func sortp list)
;; eventually sortp will be nil, t, or sort function
(let (buf vec (len (length list)))
(setq buf (current-buffer))
(switch-to-buffer (get-buffer-create name))
(setq buffer-read-only nil)
(erase-buffer) ;in case we reused the buffer
(and sortp
(setq list
(sort list (function (lambda (x y)
(string-lessp (car x) (car y))))))
)
(setq vec
(apply 'vector
(mapcar
(function (lambda (x)
(cond ((consp x)
(insert (car x))
(newline)
(cdr x))
(t
(insert x)
(newline)
x)
)
))
list)
))
(goto-char (point-min))
(smalltalk-br-mode func vec)
(set-buffer buf)
;; (switch-to-buffer buf)
;; (switch-to-buffer-other-window buf)
;; (other-window 1)
)
)
(defun smalltalk-method-browse (buf-name list)
;; eventually sortp will be nil, t, or sort function
(let (buf vec (len (length list)))
(setq buf (current-buffer))
(pop-to-buffer (get-buffer-create buf-name))
(setq buffer-read-only nil)
(erase-buffer) ;in case we reused the buffer
(setq indent-tabs-mode nil)
(setq list
(sort list (function (lambda (x y)
(string-lessp (car x) (car y))))))
(setq vec
(apply 'vector
(mapcar
(function (lambda (x)
(cond ((consp x)
(insert " " (car x))
(newline)
(cdr x))
(t
(insert " " x)
(newline)
x)
)
))
list)
))
(goto-char (point-min))
(smalltalk-method-br-mode vec)
;; (set-buffer buf)
;; (switch-to-buffer buf)
;; (switch-to-buffer-other-window buf)
;; (other-window 1)
)
)
(defun smalltalk-hier-browser (list)
;; list is this way instead of &rest so that we don't need tons of quotes
(let (buf vec (len (length list)))
(setq buf (current-buffer))
(switch-to-buffer (get-buffer-create "ST Hierarchy"))
(setq buffer-read-only nil)
(setq indent-tabs-mode nil)
(erase-buffer) ;in case we reused the buffer
(setq vec
(apply 'vector
(mapcar
(function (lambda (x)
(indent-to (+ (* (cdr x) 2) 3))
(insert (car x))
(newline)
(car x)
))
list)
))
(goto-char (point-min))
(smalltalk-hier-br-mode vec)
;; this line removed to try to fix the char gobbling bug
;; (set-buffer buf)
;; (switch-to-buffer buf)
;; (switch-to-buffer-other-window buf)
;; (other-window 1)
)
)
(defun smalltalk-br-browse-def ()
(interactive)
(let (line)
(save-restriction
(widen)
(save-excursion
(beginning-of-line)
(setq line (count-lines 1 (point)))
)
)
(funcall smalltalk-br-func (aref smalltalk-br-vector line))
)
)
(defun smalltalk-arrow-br-browse-def (arg)
(interactive "p")
(let (line)
(save-restriction
(widen)
(save-excursion
(beginning-of-line)
(smalltalk-set-indicator)
(setq line (count-lines 1 (point)))
)
)
(funcall smalltalk-br-func (aref smalltalk-br-vector line) arg)
)
)
(defun smalltalk-browse-direct-methods (arg)
(interactive "p")
(let (line)
(setq line (smalltalk-prepare-method-browsing "*Direct Methods*"))
; (smalltalk-show-direct-class-methods class-name)
(smalltalk-show-direct-instance-methods (aref smalltalk-br-vector line))
)
)
(defun smalltalk-browse-all-methods (arg)
(interactive "p")
(let (line)
(setq line (smalltalk-prepare-method-browsing "*All Methods*"))
; (smalltalk-show-direct-class-methods class-name)
(smalltalk-show-all-instance-methods (aref smalltalk-br-vector line))
)
)
(defun smalltalk-browse-indirect-methods (arg)
(interactive "p")
(let (line)
(setq line (smalltalk-prepare-method-browsing "*Indirect Methods*"))
; (smalltalk-show-direct-class-methods class-name)
(smalltalk-show-indirect-instance-methods (aref smalltalk-br-vector line))
)
)
(defun smalltalk-browse-class-methods (arg)
(interactive "p")
(let (line)
(setq line (smalltalk-prepare-method-browsing "*Direct Class Methods*"))
(smalltalk-show-direct-class-methods (aref smalltalk-br-vector line))
)
)
(defun smalltalk-prepare-method-browsing (buf-name)
(let (line buf cur-buf)
(setq cur-buf (current-buffer))
(beginning-of-line)
(smalltalk-set-indicator)
(setq line (count-lines 1 (point)))
(setq buf (get-buffer-create buf-name))
(delete-other-windows)
(split-window-vertically)
(split-window-horizontally)
(other-window 1)
(switch-to-buffer buf)
(let ((buffer-read-only nil))
(erase-buffer))
(other-window -1)
line)
)
(defun smalltalk-set-indicator ()
(let ((buffer-read-only nil))
(save-excursion
(and smalltalk-prev-indicator
(save-excursion
(goto-char smalltalk-prev-indicator)
(smalltalk-replace-chars
(make-string (length smalltalk-indicator) ? ))
)
)
(setq smalltalk-prev-indicator (point))
(smalltalk-replace-chars smalltalk-indicator)
)
)
)
(defun smalltalk-replace-chars (str)
(delete-char (length str))
(insert str))
(defun smalltalk-br-selected (class-name arg)
(let (buf is-meta)
(setq is-meta (/= arg 1))
(setq buf (get-buffer-create (if is-meta "*Class Methods*" "*Methods*")))
(delete-other-windows)
(split-window-vertically)
(split-window-horizontally)
(other-window 1)
(switch-to-buffer buf)
(let ((buffer-read-only nil))
(erase-buffer))
(if is-meta
(smalltalk-show-direct-class-methods class-name)
(smalltalk-show-direct-instance-methods class-name)
)
)
)
;(smalltalk-browse
; "zoneball"
; 'test-func
; '(("foo:" . "bar")
; ("quem:" . "zoneball")
; ("ducks:" . "inARow"))
; )